home *** CD-ROM | disk | FTP | other *** search
- ;;; -*- Package: LOOP -*-
- ;;;
- ;;; **********************************************************************
- ;;; This code was written as part of the CMU Common Lisp project at
- ;;; Carnegie Mellon University, and has been placed in the public domain.
- ;;; If you want to use this code or any part of CMU Common Lisp, please contact
- ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
- ;;;
- (ext:file-comment
- "$Header: loop.lisp,v 1.8 91/05/24 19:37:33 wlott Exp $")
- ;;;
- ;;; **********************************************************************
- ;;;
- ;;; $Header: loop.lisp,v 1.8 91/05/24 19:37:33 wlott Exp $
- ;;;
- ;;; Loop facility, written by William Lott.
- ;;;
- (in-package "LOOP")
-
- (in-package "LISP")
- (export '(loop loop-finish))
-
- (in-package "LOOP")
-
-
- ;;;; Specials used during the parse.
-
- ;;; These specials hold the different parts of the result as we are generating
- ;;; them.
- ;;;
- (defvar *loop-name*)
- (defvar *outside-bindings*)
- (defvar *prologue*)
- (defvar *inside-bindings*)
- (defvar *body-forms*)
- (defvar *iteration-forms*)
- (defvar *epilogue*)
- (defvar *result-var*)
- (defvar *return-value*)
- (defvar *default-return-value*)
- (defvar *accumulation-variables*)
-
- ;;; This special holds the remaining stuff we need to parse.
- ;;;
- (defvar *remaining-stuff*)
-
- ;;; This special holds a value that is EQ only to itself.
- ;;;
- (defvar *magic-cookie* (list '<magic-cookie>))
-
-
- ;;;; Utility functions/macros used by the parser.
-
- (proclaim '(inline maybe-car maybe-cdr))
-
- (defun maybe-car (thing)
- (if (consp thing) (car thing) thing))
-
- (defun maybe-cdr (thing)
- (if (consp thing) (cdr thing) thing))
-
-
- (defmacro loop-keyword-p (thing keyword &rest more-keywords)
- `(let ((thing ,thing))
- (and (symbolp thing)
- (let ((name (symbol-name thing)))
- (or ,@(mapcar #'(lambda (keyword)
- `(string= name ,keyword))
- (cons keyword more-keywords)))))))
-
- (defun preposition-p (prep)
- (when (loop-keyword-p (car *remaining-stuff*) prep)
- (pop *remaining-stuff*)
- t))
-
-
- (defun splice-in-subform (form subform)
- (if (eq form *magic-cookie*)
- subform
- (labels ((sub-splice-in-subform (form path)
- (cond ((atom form)
- nil)
- ((member form path)
- nil)
- ((eq (car form) *magic-cookie*)
- (setf (car form) subform)
- t)
- (t
- (let ((new-path (cons form path)))
- (or (sub-splice-in-subform (car form) new-path)
- (sub-splice-in-subform (cdr form) new-path)))))))
- (if (sub-splice-in-subform form nil)
- form
- (error "Couldn't find the magic cookie in:~% ~S~%Loop is broken."
- form)))))
-
- (defmacro queue-var (where name type &key
- (initer nil initer-p) (stepper nil stepper-p))
- `(push (list ,name ,type ,initer-p ,initer ,stepper-p ,stepper)
- ,where))
-
- (defvar *default-values* '(nil 0 0.0)
- "The different possible default values. When we need a default value, we
- use the first value in this list that is typep the desired type.")
-
- (defun pick-default-value (var type)
- (if (consp var)
- (cons (pick-default-value (car var) (maybe-car type))
- (pick-default-value (cdr var) (maybe-cdr type)))
- (dolist (default *default-values*
- (error "Cannot default variables of type ~S ~
- (for variable ~S)."
- type var))
- (when (typep default type)
- (return default)))))
-
- (defun only-simple-types (type-spec)
- (if (atom type-spec)
- (member type-spec '(fixnum float t nil))
- (and (only-simple-types (car type-spec))
- (only-simple-types (cdr type-spec)))))
-
-
- (defun build-let-expression (vars)
- (if (null vars)
- (values *magic-cookie* *magic-cookie*)
- (let ((inside nil)
- (outside nil)
- (steppers nil)
- (sub-lets nil))
- (dolist (var vars)
- (labels
- ((process (name type initial-p initial stepper-p stepper)
- (cond ((atom name)
- (cond ((not stepper-p)
- (push (list type name initial) outside))
- ((not initial-p)
- (push (list type name stepper) inside))
- (t
- (push (list type name initial) outside)
- (setf steppers
- (nconc steppers (list name stepper))))))
- ((and (car name) (cdr name))
- (let ((temp (gensym (format nil "TEMP-FOR-~A-" name))))
- (process temp 'list initial-p initial
- stepper-p stepper)
- (push (if stepper-p
- (list (car name)
- (maybe-car type)
- nil nil
- t `(car ,temp))
- (list (car name)
- (maybe-car type)
- t `(car ,temp)
- nil nil))
- sub-lets)
- (push (if stepper-p
- (list (cdr name)
- (maybe-cdr type)
- nil nil
- t `(cdr ,temp))
- (list (car name)
- (maybe-cdr type)
- t `(cdr ,temp)
- nil nil))
- sub-lets)))
- ((car name)
- (process (car name)
- (maybe-car type)
- initial-p `(car ,initial)
- stepper-p `(car ,stepper)))
- ((cdr name)
- (process (cdr name)
- (maybe-cdr type)
- initial-p `(cdr ,initial)
- stepper-p `(cdr ,stepper))))))
- (process (first var) (second var) (third var)
- (fourth var) (fifth var) (sixth var))))
- (when steppers
- (push (cons 'psetq steppers)
- *iteration-forms*))
- (multiple-value-bind
- (sub-outside sub-inside)
- (build-let-expression sub-lets)
- (values (build-bindings outside sub-outside)
- (build-bindings inside sub-inside))))))
-
- (defun build-bindings (vars guts)
- (if (null vars)
- guts
- `(let ,(mapcar #'cdr vars)
- (declare ,@(mapcar #'build-declare vars))
- ,guts)))
-
- (defun build-declare (var)
- `(type ,(car var) ,(cadr var)))
-
-
-
- ;;;; LOOP itself.
-
- (defmacro loop (&rest stuff)
- "General iteration facility. See the manual for details, 'cause it's
- very confusing."
- (if (some #'atom stuff)
- (parse-loop stuff)
- (let ((repeat (gensym "REPEAT-"))
- (out-of-here (gensym "OUT-OF-HERE-")))
- `(block nil
- (tagbody
- ,repeat
- (macrolet ((loop-finish () `(go ,out-of-here)))
- ,@stuff)
- (go ,repeat)
- ,out-of-here)))))
-
-
-
- ;;;; The parser.
-
- ;;; Top level parser. Bind the specials, and call the other parsers.
- ;;;
- (defun parse-loop (stuff)
- (let* ((*prologue* nil)
- (*outside-bindings* *magic-cookie*)
- (*inside-bindings* *magic-cookie*)
- (*body-forms* nil)
- (*iteration-forms* nil)
- (*epilogue* nil)
- (*result-var* nil)
- (*return-value* nil)
- (*default-return-value* nil)
- (*accumulation-variables* nil)
- (*remaining-stuff* stuff)
- (name (parse-named)))
- (loop
- (when (null *remaining-stuff*)
- (return))
- (let ((clause (pop *remaining-stuff*)))
- (cond ((not (symbolp clause))
- (error "Invalid clause, ~S, must be a symbol." clause))
- ((loop-keyword-p clause "INITIALLY")
- (setf *prologue* (nconc *prologue* (parse-expr-list))))
- ((loop-keyword-p clause "FINALLY")
- (parse-finally))
- ((loop-keyword-p clause "WITH")
- (parse-with))
- ((loop-keyword-p clause "FOR" "AS")
- (parse-for-as))
- ((loop-keyword-p clause "REPEAT")
- (parse-repeat))
- (t
- (push clause *remaining-stuff*)
- (return)))))
- (loop
- (when (null *remaining-stuff*)
- (return))
- (let ((clause (pop *remaining-stuff*)))
- (cond ((not (symbolp clause))
- (error "Invalid clause, ~S, must be a symbol." clause))
- ((loop-keyword-p clause "INITIALLY")
- (setf *prologue* (nconc *prologue* (parse-expr-list))))
- ((loop-keyword-p clause "FINALLY")
- (parse-finally))
- ((loop-keyword-p clause "WHILE")
- (setf *body-forms*
- (nconc *body-forms*
- `((unless ,(pop *remaining-stuff*)
- (loop-finish))))))
- ((loop-keyword-p clause "UNTIL")
- (setf *body-forms*
- (nconc *body-forms*
- `((when ,(pop *remaining-stuff*) (loop-finish))))))
- ((loop-keyword-p clause "ALWAYS")
- (setf *body-forms*
- (nconc *body-forms*
- `((unless ,(pop *remaining-stuff*)
- (return-from ,name nil)))))
- (setf *default-return-value* t))
- ((loop-keyword-p clause "NEVER")
- (setf *body-forms*
- (nconc *body-forms*
- `((when ,(pop *remaining-stuff*)
- (return-from ,name nil)))))
- (setf *default-return-value* t))
- ((loop-keyword-p clause "THEREIS")
- (setf *body-forms*
- (nconc *body-forms*
- (let ((temp (gensym "THEREIS-")))
- `((let ((,temp ,(pop *remaining-stuff*)))
- (when ,temp
- (return-from ,name ,temp))))))))
- (t
- (push clause *remaining-stuff*)
- (or (maybe-parse-unconditional)
- (maybe-parse-conditional)
- (maybe-parse-accumulation)
- (error "Unknown clause, ~S" clause))))))
- (let ((again-tag (gensym "AGAIN-"))
- (end-tag (gensym "THIS-IS-THE-END-")))
- `(block ,name
- ,(splice-in-subform
- *outside-bindings*
- `(macrolet ((loop-finish () '(go ,end-tag)))
- (tagbody
- ,@*prologue*
- ,again-tag
- ,(splice-in-subform
- *inside-bindings*
- `(progn
- ,@*body-forms*
- ,@(nreverse *iteration-forms*)))
- (go ,again-tag)
- ,end-tag
- ,@*epilogue*
- (return-from ,name
- ,(or *return-value*
- *default-return-value*
- *result-var*)))))))))
-
- (defun parse-named ()
- (when (loop-keyword-p (car *remaining-stuff*) "NAMED")
- (pop *remaining-stuff*)
- (if (symbolp (car *remaining-stuff*))
- (pop *remaining-stuff*)
- (error "Loop name ~S is not a symbol." (car *remaining-stuff*)))))
-
-
- (defun parse-expr-list ()
- (let ((results nil))
- (loop
- (when (atom (car *remaining-stuff*))
- (return (nreverse results)))
- (push (pop *remaining-stuff*) results))))
-
- (defun parse-finally ()
- (let ((sub-clause (pop *remaining-stuff*)))
- (if (loop-keyword-p sub-clause "RETURN")
- (cond ((not (null *return-value*))
- (error "Cannot specify two FINALLY RETURN clauses."))
- ((null *remaining-stuff*)
- (error "FINALLY RETURN must be followed with an expression."))
- (t
- (setf *return-value* (pop *remaining-stuff*))))
- (progn
- (unless (loop-keyword-p sub-clause "DO" "DOING")
- (push sub-clause *remaining-stuff*))
- (setf *epilogue* (nconc *epilogue* (parse-expr-list)))))))
-
- (defun parse-with ()
- (let ((vars nil))
- (loop
- (multiple-value-bind (var type) (parse-var-and-type-spec)
- (let ((initial
- (if (loop-keyword-p (car *remaining-stuff*) "=")
- (progn
- (pop *remaining-stuff*)
- (pop *remaining-stuff*))
- (list 'quote
- (pick-default-value var type)))))
- (queue-var vars var type :initer initial)))
- (if (loop-keyword-p (car *remaining-stuff*) "AND")
- (pop *remaining-stuff*)
- (return)))
- (multiple-value-bind
- (outside inside)
- (build-let-expression vars)
- (setf *outside-bindings*
- (splice-in-subform *outside-bindings* outside))
- (setf *inside-bindings*
- (splice-in-subform *inside-bindings* inside)))))
-
- (defun parse-var-and-type-spec ()
- (values (pop *remaining-stuff*)
- (parse-type-spec t)))
-
- (defun parse-type-spec (default)
- (cond ((preposition-p "OF-TYPE")
- (pop *remaining-stuff*))
- ((and *remaining-stuff*
- (only-simple-types (car *remaining-stuff*)))
- (pop *remaining-stuff*))
- (t
- default)))
-
-
-
- ;;;; FOR/AS stuff.
-
- ;;; These specials hold the vars that need to be bound for this FOR/AS clause
- ;;; and all of the FOR/AS clauses connected with AND. All the *for-as-vars*
- ;;; are bound in parallel followed by the *for-as-sub-vars*.
- ;;;
- (defvar *for-as-vars*)
- (defvar *for-as-sub-vars*)
-
- ;;; These specials hold any extra termination tests. *for-as-term-tests* are
- ;;; processed after the *for-as-vars* are bound, but before the
- ;;; *for-as-sub-vars*. *for-as-sub-term-tests* are processed after the
- ;;; *for-as-sub-vars*.
-
- (defvar *for-as-term-tests*)
- (defvar *for-as-sub-term-tests*)
-
-
- (defun parse-for-as ()
- (let ((*for-as-vars* nil)
- (*for-as-term-tests* nil)
- (*for-as-sub-vars* nil)
- (*for-as-sub-term-tests* nil))
- (loop
- (multiple-value-bind (name type) (parse-var-and-type-spec)
- (let ((sub-clause (pop *remaining-stuff*)))
- (cond ((loop-keyword-p sub-clause "FROM" "DOWNFROM" "UPFROM"
- "TO" "DOWNTO" "UPTO" "BELOW" "ABOVE")
- (parse-arithmetic-for-as sub-clause name type))
- ((loop-keyword-p sub-clause "IN")
- (parse-in-for-as name type))
- ((loop-keyword-p sub-clause "ON")
- (parse-on-for-as name type))
- ((loop-keyword-p sub-clause "=")
- (parse-equals-for-as name type))
- ((loop-keyword-p sub-clause "ACROSS")
- (parse-across-for-as name type))
- ((loop-keyword-p sub-clause "BEING")
- (parse-being-for-as name type))
- (t
- (error "Invalid FOR/AS subclause: ~S" sub-clause)))))
- (if (loop-keyword-p (car *remaining-stuff*) "AND")
- (pop *remaining-stuff*)
- (return)))
- (multiple-value-bind
- (outside inside)
- (build-let-expression *for-as-vars*)
- (multiple-value-bind
- (sub-outside sub-inside)
- (build-let-expression *for-as-sub-vars*)
- (setf *outside-bindings*
- (splice-in-subform *outside-bindings*
- (splice-in-subform outside sub-outside)))
- (let ((inside-body
- (if *for-as-term-tests*
- `(if (or ,@(nreverse *for-as-term-tests*))
- (loop-finish)
- ,*magic-cookie*)
- *magic-cookie*))
- (sub-inside-body
- (if *for-as-sub-term-tests*
- `(if (or ,@(nreverse *for-as-sub-term-tests*))
- (loop-finish)
- ,*magic-cookie*)
- *magic-cookie*)))
- (setf *inside-bindings*
- (splice-in-subform
- *inside-bindings*
- (splice-in-subform
- inside
- (splice-in-subform
- inside-body
- (splice-in-subform
- sub-inside
- sub-inside-body))))))))))
-
- (defun parse-arithmetic-for-as (sub-clause name type)
- (unless (atom name)
- (error "Cannot destructure arithmetic FOR/AS variables: ~S" name))
- (let (start stop (inc 1) dir exclusive-p)
- (cond ((loop-keyword-p sub-clause "FROM")
- (setf start (pop *remaining-stuff*)))
- ((loop-keyword-p sub-clause "DOWNFROM")
- (setf start (pop *remaining-stuff*))
- (setf dir :down))
- ((loop-keyword-p sub-clause "UPFROM")
- (setf start (pop *remaining-stuff*))
- (setf dir :up))
- (t
- (push sub-clause *remaining-stuff*)))
- (cond ((preposition-p "TO")
- (setf stop (pop *remaining-stuff*)))
- ((preposition-p "DOWNTO")
- (setf stop (pop *remaining-stuff*))
- (if (eq dir :up)
- (error "Can't mix UPFROM and DOWNTO in ~S." name)
- (setf dir :down)))
- ((preposition-p "UPTO")
- (setf stop (pop *remaining-stuff*))
- (if (eq dir :down)
- (error "Can't mix DOWNFROM and UPTO in ~S." name)
- (setf dir :up)))
- ((preposition-p "ABOVE")
- (setf stop (pop *remaining-stuff*))
- (setf exclusive-p t)
- (if (eq dir :up)
- (error "Can't mix UPFROM and ABOVE in ~S." name)
- (setf dir :down)))
- ((preposition-p "BELOW")
- (setf stop (pop *remaining-stuff*))
- (setf exclusive-p t)
- (if (eq dir :down)
- (error "Can't mix DOWNFROM and BELOW in ~S." name)
- (setf dir :up))))
- (when (preposition-p "BY")
- (setf inc (pop *remaining-stuff*)))
- (when (and (eq dir :down) (null start))
- (error "No default starting value for decremental stepping."))
- (let ((temp (gensym "TEMP-AMOUNT-")))
- (queue-var *for-as-sub-vars* temp type :initer inc)
- (queue-var *for-as-sub-vars* name type
- :initer (or start 0)
- :stepper `(,(if (eq dir :down) '- '+) ,name ,temp))
- (when stop
- (let ((stop-var (gensym "STOP-VAR-")))
- (queue-var *for-as-sub-vars* stop-var type :initer stop)
- (push (list (if (eq dir :down)
- (if exclusive-p '<= '<)
- (if exclusive-p '>= '>))
- name stop-var)
- *for-as-sub-term-tests*))))))
-
- (defun parse-in-for-as (name type)
- (let* ((temp (gensym "LIST-"))
- (initer (pop *remaining-stuff*))
- (stepper (if (preposition-p "BY")
- `(funcall ,(pop *remaining-stuff*) ,temp)
- `(cdr ,temp))))
- (queue-var *for-as-vars* temp 'list :initer initer :stepper stepper)
- (queue-var *for-as-sub-vars* name type :stepper `(car ,temp))
- (push `(null ,temp) *for-as-sub-term-tests*)))
-
- (defun parse-on-for-as (name type)
- (let* ((temp (if (atom name) name (gensym "LIST-")))
- (initer (pop *remaining-stuff*))
- (stepper (if (preposition-p "BY")
- `(funcall ,(pop *remaining-stuff*) ,temp)
- `(cdr ,temp))))
- (cond ((atom name)
- (queue-var *for-as-sub-vars* name type
- :initer initer :stepper stepper)
- (push `(endp ,name) *for-as-sub-term-tests*))
- (t
- (queue-var *for-as-vars* temp type
- :initer initer :stepper stepper)
- (queue-var *for-as-sub-vars* name type :stepper temp)
- (push `(endp ,temp) *for-as-term-tests*)))))
-
- (defun parse-equals-for-as (name type)
- (let ((initer (pop *remaining-stuff*)))
- (if (preposition-p "THEN")
- (queue-var *for-as-sub-vars* name type
- :initer initer :stepper (pop *remaining-stuff*))
- (queue-var *for-as-vars* name type :stepper initer))))
-
- (defun parse-across-for-as (name type)
- (let* ((temp (gensym "VECTOR-"))
- (length (gensym "LENGTH-"))
- (index (gensym "INDEX-")))
- (queue-var *for-as-vars* temp `(vector ,type)
- :initer (pop *remaining-stuff*))
- (queue-var *for-as-sub-vars* length 'fixnum
- :initer `(length ,temp))
- (queue-var *for-as-vars* index 'fixnum :initer 0 :stepper `(1+ ,index))
- (queue-var *for-as-sub-vars* name type :stepper `(aref ,temp ,index))
- (push `(>= ,index ,length) *for-as-term-tests*)))
-
- (defun parse-being-for-as (name type)
- (let ((clause (pop *remaining-stuff*)))
- (unless (loop-keyword-p clause "EACH" "THE")
- (error "BEING must be followed by either EACH or THE, not ~S"
- clause)))
- (let ((clause (pop *remaining-stuff*)))
- (cond ((loop-keyword-p clause "HASH-KEY" "HASH-KEYS"
- "HASH-VALUE" "HASH-VALUES")
- (let ((prep (pop *remaining-stuff*)))
- (unless (loop-keyword-p prep "IN" "OF")
- (error "~A must be followed by either IN or OF, not ~S"
- (symbol-name clause) prep)))
- (let ((table (pop *remaining-stuff*))
- (iterator (gensym (format nil "~A-ITERATOR-" name)))
- (exists-temp (gensym (format nil "~A-EXISTS-TEMP-" name)))
- (key-temp (gensym (format nil "~A-KEY-TEMP-" name)))
- (value-temp (gensym (format nil "~A-VALUE-TEMP-" name))))
- (setf *outside-bindings*
- (splice-in-subform
- *outside-bindings*
- `(with-hash-table-iterator (,iterator ,table)
- ,*magic-cookie*)))
- (multiple-value-bind
- (using using-type)
- (when (preposition-p "USING")
- ;; ### This is wrong.
- (parse-var-and-type-spec))
- (multiple-value-bind
- (key-var key-type value-var value-type)
- (if (loop-keyword-p clause "HASH-KEY" "HASH-KEYS")
- (values name type using using-type)
- (values using using-type name type))
- (setf *inside-bindings*
- (splice-in-subform
- *inside-bindings*
- `(multiple-value-bind
- (,exists-temp ,key-temp ,value-temp)
- (,iterator)
- ,@(unless (and key-var value-var)
- `((declare (ignore ,@(if (null key-var)
- (list key-temp))
- ,@(if (null value-var)
- (list value-temp))))))
- ,*magic-cookie*)))
- (push `(not ,exists-temp) *for-as-term-tests*)
- (when key-var
- (queue-var *for-as-sub-vars* key-var key-type
- :stepper key-temp))
- (when value-var
- (queue-var *for-as-sub-vars* value-var value-type
- :stepper value-temp))))))
- ((loop-keyword-p clause "SYMBOL" "PRESENT-SYMBOL" "EXTERNAL-SYMBOL"
- "SYMBOLS" "PRESENT-SYMBOLS" "EXTERNAL-SYMBOLS")
- (let ((package
- (if (or (preposition-p "IN")
- (preposition-p "OF"))
- (pop *remaining-stuff*)
- '*package*))
- (iterator (gensym (format nil "~A-ITERATOR-" name)))
- (exists-temp (gensym (format nil "~A-EXISTS-TEMP-" name)))
- (symbol-temp (gensym (format nil "~A-SYMBOL-TEMP-" name))))
- (setf *outside-bindings*
- (splice-in-subform
- *outside-bindings*
- `(with-package-iterator
- (,iterator
- ,package
- ,@(cond ((loop-keyword-p clause "SYMBOL" "SYMBOLS")
- '(:internal :external :inherited))
- ((loop-keyword-p clause "PRESENT-SYMBOL"
- "PRESENT-SYMBOLS")
- '(:internal))
- ((loop-keyword-p clause "EXTERNAL-SYMBOL"
- "EXTERNAL-SYMBOLS")
- '(:external))
- (t
- (error "Don't know how to deal with ~A? ~
- Bug in LOOP?" clause))))
- ,*magic-cookie*)))
- (setf *inside-bindings*
- (splice-in-subform
- *inside-bindings*
- `(multiple-value-bind
- (,exists-temp ,symbol-temp)
- (,iterator)
- ,*magic-cookie*)))
- (push `(not ,exists-temp) *for-as-term-tests*)
- (queue-var *for-as-sub-vars* name type :stepper symbol-temp)))
- (t
- (error
- "Unknown sub-clause, ~A, for BEING. Must be one of:~% ~
- HASH-KEY HASH-KEYS HASH-VALUE HASH-VALUES SYMBOL SYMBOLS~% ~
- PRESENT-SYMBOL PRESENT-SYMBOLS EXTERNAL-SYMBOL EXTERNAL-SYMBOLS"
- (symbol-name clause))))))
-
-
-
- ;;;;
-
- (defun parse-repeat ()
- (let ((temp (gensym "REPEAT-")))
- (setf *outside-bindings*
- (splice-in-subform *outside-bindings*
- `(let ((,temp ,(pop *remaining-stuff*)))
- ,*magic-cookie*)))
- (setf *inside-bindings*
- (splice-in-subform *inside-bindings*
- `(if (minusp (decf ,temp))
- (loop-finish)
- ,*magic-cookie*)))))
-
-
- (defun maybe-parse-unconditional ()
- (when (loop-keyword-p (car *remaining-stuff*) "DO" "DOING")
- (pop *remaining-stuff*)
- (setf *body-forms* (nconc *body-forms* (parse-expr-list)))
- t))
-
- (defun maybe-parse-conditional ()
- (let ((clause (pop *remaining-stuff*)))
- (cond ((loop-keyword-p clause "IF" "WHEN")
- (parse-conditional (pop *remaining-stuff*))
- t)
- ((loop-keyword-p clause "UNLESS")
- (parse-conditional `(not ,(pop *remaining-stuff*)))
- t)
- (t
- (push clause *remaining-stuff*)
- nil))))
-
- (defun parse-conditional (condition)
- (let ((clauses (parse-and-clauses))
- (else-clauses (when (preposition-p "ELSE")
- (parse-and-clauses))))
- (setf *body-forms*
- (nconc *body-forms*
- `((if ,condition
- (progn
- ,@clauses)
- (progn
- ,@else-clauses)))))
- (preposition-p "END")))
-
- (defun parse-and-clauses ()
- (let ((*body-forms* nil))
- (loop
- (or (maybe-parse-unconditional)
- (maybe-parse-conditional)
- (maybe-parse-accumulation)
- (error "Invalid clause for inside a conditional: ~S"
- (car *remaining-stuff*)))
- (unless (preposition-p "AND")
- (return *body-forms*)))))
-
-
- ;;;; Assumulation stuff
-
- (defun maybe-parse-accumulation ()
- (when (loop-keyword-p (car *remaining-stuff*)
- "COLLECT" "COLLECTING"
- "APPEND" "APPENDING" "NCONC" "NCONCING"
- "COUNT" "COUNTING" "SUM" "SUMMING"
- "MAXIMIZE" "MAXIMIZING" "MINIMIZE" "MINIMIZING")
- (parse-accumulation)
- t))
-
- (defun parse-accumulation ()
- (let* ((clause (pop *remaining-stuff*))
- (expr (pop *remaining-stuff*))
- (var (if (preposition-p "INTO")
- (pop *remaining-stuff*)
- (or *result-var*
- (setf *result-var*
- (gensym (concatenate 'simple-string
- (string clause)
- "-"))))))
- (info (assoc var *accumulation-variables*))
- (type nil)
- (initial nil))
- (cond ((loop-keyword-p clause "COLLECT" "COLLECTING" "APPEND" "APPENDING"
- "NCONC" "NCONCING")
- (setf initial nil)
- (setf type 'list)
- (let ((aux-var
- (or (caddr info)
- (let ((aux-var (gensym "LAST-")))
- (setf *outside-bindings*
- (splice-in-subform *outside-bindings*
- `(let ((,var nil)
- (,aux-var nil))
- (declare (type list
- ,var
- ,aux-var))
- ,*magic-cookie*)))
- (if (null info)
- (push (setf info (list var 'list aux-var))
- *accumulation-variables*)
- (setf (cddr info) (list aux-var)))
- aux-var)))
- (value
- (cond ((loop-keyword-p clause "COLLECT" "COLLECTING")
- `(list ,expr))
- ((loop-keyword-p clause "APPEND" "APPENDING")
- `(copy-list ,expr))
- ((loop-keyword-p clause "NCONC" "NCONCING")
- expr)
- (t
- (error "Bug in loop?")))))
- (setf *body-forms*
- (nconc *body-forms*
- `((cond ((null ,var)
- (setf ,var ,value)
- (setf ,aux-var (last ,var)))
- (t
- (nconc ,aux-var ,value)
- (setf ,aux-var (last ,aux-var)))))))))
- ((loop-keyword-p clause "COUNT" "COUNTING")
- (setf type (parse-type-spec 'unsigned-byte))
- (setf initial 0)
- (setf *body-forms*
- (nconc *body-forms*
- `((when ,expr (incf ,var))))))
- ((loop-keyword-p clause "SUM" "SUMMING")
- (setf type (parse-type-spec 'number))
- (setf initial 0)
- (setf *body-forms*
- (nconc *body-forms*
- `((incf ,var ,expr)))))
- ((loop-keyword-p clause "MAXIMIZE" "MAXIMIZING")
- (setf type `(or null ,(parse-type-spec 'number)))
- (setf initial nil)
- (setf *body-forms*
- (nconc *body-forms*
- (let ((temp (gensym "MAX-TEMP-")))
- `((let ((,temp ,expr))
- (when (or (null ,var)
- (> ,temp ,var))
- (setf ,var ,temp))))))))
- ((loop-keyword-p clause "MINIMIZE" "MINIMIZING")
- (setf type `(or null ,(parse-type-spec 'number)))
- (setf initial nil)
- (setf *body-forms*
- (nconc *body-forms*
- (let ((temp (gensym "MIN-TEMP-")))
- `((let ((,temp ,expr))
- (when (or (null ,var)
- (< ,temp ,var))
- (setf ,var ,temp))))))))
- (t
- (error "Invalid accumulation clause: ~S" clause)))
- (cond (info
- (unless (equal type (cadr info))
- (error "Attempt to use ~S for both types ~S and ~S."
- var type (cadr info))))
- (t
- (push (list var type) *accumulation-variables*)
- (setf *outside-bindings*
- (splice-in-subform *outside-bindings*
- `(let ((,var ,initial))
- (declare (type ,type ,var))
- ,*magic-cookie*)))))))
-